;; Copyright (c) 2022 bobwxc@yeah.net
;; This program is free software: you can redistribute it and/or modify it under
;; the terms of the GNU Lesser General Public License as published by the Free Software
;; Foundation, either version 3 of the License, or (at your option) any later
;; version.
;; This program is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;; details.
;; You should have received a copy of the GNU General Public License along with
;; this program. If not, see <https://www.gnu.org/licenses/>.

(in-package #:simple-tar)

(defun read-512 (st)
  (declare (stream st))
  (let ((r (make-list 512
                      :initial-element nil)))
    (read-sequence r st)
    r))

(defun octal-string-to-number (str &optional (n 0))
  "decode number in octal string format"
  (declare ((or string null) str))
  (setf str (subseq str 0 (position #\Nul str))) ;; w minus and a null
  (if (= n (- (length str) 1))
      (- (char-code (char str n)) 48)
    (if (equal (char str n) #\0)
        (octal-string-to-number str (+ n 1))
      (+ (* (expt 8 (- (length str) n 1))
            (- (char-code (char str n)) 48))
         (octal-string-to-number str (+ n 1))))))

(defun string-decode (lst)
  "utf8 decode and trim right #\Nul(0x00)"
  (declare (list lst))
  (string-right-trim '(#\Nul) (u8c:decode-to-string lst)))

(defun calcu-chksum (ar)
  "calcuate checksum of tar header"
  (declare ((and list (not null)) ar))
  (+ (apply #'+ (subseq ar 0 148))
     (apply #'+ (subseq ar 156 512))
     256)) ;; 8 blank = 8 * 0x20 = 256

(defun decode-head (ar)
  "deocde tar header
   ar: list of unsigned-byte 8
   more information about tar head see /usr/include/tar.h
   or https://www.gnu.org/software/tar/manual/html_chapter/Tar-Internals.html"
  (declare ((and list (not null)) ar))
  (let ((t-name (string-decode (subseq ar 0 100))) ; 100 string
        (t-mode (string-decode (subseq ar 100 108))) ; 8
        (t-uid (octal-string-to-number (string-decode (subseq ar 108 116)))) ; 8
        (t-gid (octal-string-to-number (string-decode (subseq ar 116 124)))) ; 8
        (t-size (octal-string-to-number (string-decode (subseq ar 124 136)))) ; 12
        (t-mtime (octal-string-to-number (string-decode (subseq ar 136 148)))) ; 12
        (t-chksum (octal-string-to-number (string-decode (subseq ar 148 156)))) ; 8
        (t-typeflag (string-decode (subseq ar 156 157))) ; 1
        (t-linkname (string-decode (subseq ar 157 257))) ; 100 string
        (t-magic (string-decode (subseq ar 257 263))) ; 6 string
        (t-version (string-decode (subseq ar 263 265))) ; 2
        (t-uname (string-decode (subseq ar 265 297))) ; 32 string
        (t-gname (string-decode (subseq ar 297 329))) ; 32 string
        (t-devmajor (string-decode (subseq ar 329 337))) ; 8
        (t-devminor (string-decode (subseq ar 337 345))) ; 8
        (t-prefix (string-decode (subseq ar 345 500))) ; 155
        )
    (let ((flag 0))
      (when (not (equal t-magic "ustar "))
        (warn "tar head magic error, expect \"ustar \", get ~S" t-magic)
        (incf flag))
      (when (/= t-chksum (calcu-chksum ar))
        (warn "tar head chksum error, expect ~D, get ~D" (calcu-chksum ar) t-chksum)
        (incf flag))
      (when (= flag 2)
        (warn "Undecodeable tar head")
        (return-from decode-head nil)))
    (list
     'name t-name
     'mode t-mode
     'uid t-uid
     'gid t-gid
     'size t-size
     'mtime t-mtime
     'chksum t-chksum
     'typeflag t-typeflag
     'linkname t-linkname
     'magic t-magic
     'version t-version
     'uname t-uname
     'gname t-gname
     'devmajor t-devmajor
     'devminor t-devminor
     'prefix t-prefix)
  ))

(defun read-body (fs body-size)
  "read a tar body
   fs: unsigned-byte 8 input stream
   body-size: size in tar header"
  (declare (stream fs)
           (integer body-size))
  (let* ((nsize (ceiling (/ body-size 512)))
         (content (apply #'append
                         (loop for i from 1 to nsize
                               collect(if (/= i nsize)
                                          (read-512 fs)
                                        (subseq (read-512 fs)
                                                0
                                                (mod body-size 512)))))))
    (setf content (remove nil content))
    (when (/= body-size (length content))
      (warn "Body size un-equal: Header declaration: ~D Acturally read: ~D~%"
            body-size
            (length content)))
    content))

(defun read-one-file (fs)
  "read one file from tar
   fs: unsigned-byte 8 input stream"
  (declare (stream fs))
  (let* ((head-label (decode-head (read-512 fs)))
         (content (read-body fs (getf head-label 'size))))
    (cons head-label content)))

(defun allnil? (lst)
  "all elements are nil, return t"
  (declare (sequence lst))
  (cond
   ((not lst) t)
   ((car lst) nil)
   (t (allnil? (cdr lst)))))

(defun allzero? (lst)
  "all elements are 0, return t"
  (declare (sequence lst))
  (cond
   ((not lst) t)
   ((/= (car lst) 0) nil)
   (t (allzero? (cdr lst)))))

(defun read-all-files (fs)
  "read all files from tar
   fs: unsigned-byte 8 input stream"
  (declare (stream fs))
  (let* ((file-list '()))
    (do ((r (read-512 fs) (setf r (read-512 fs))))
        ((allnil? r) nil)
        (when (not (allzero? r))
          (let* ((head-label (decode-head r))
                 (content (read-body fs (getf head-label 'size))))
            (setf file-list
                  (append file-list
                          (list (cons head-label content))))
            )))
    file-list))

(defun read-next-file (fs)
  "read next file from tar
   fs: unsigned-byte 8 input stream"
  (declare (stream fs))
  (do ((r (read-512 fs) (setf r (read-512 fs))))
      ((allnil? r) nil)
      (when (not (allzero? r))
        (let* ((head-label (decode-head r))
               (content (read-body fs (getf head-label 'size))))
          (return (cons head-label content))))))


